home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MACD 5
/
MACD 5.bin
/
workbench
/
dir
/
dum2
/
src
/
dum2.mod
< prev
next >
Wrap
Text File
|
1987-05-28
|
19KB
|
666 lines
MODULE DuM2;
(* ANOTHER DIRECTORY Utility. This one in Modula-2 *)
(* ALL THE MODULES ARE $A+ SINCE CODE IS NOW ONLY 24800 BYTES OR SO.
IF IT GROWS A LOT, THEY MAY HAVE TO BE CHANGED TO $Q+
*)
(*$S-*)(*$T-*)(*$A+*)
(*
This is the main module for DirUtil (works from CLI or WB now)
Written: 3/21/87 by Greg Browne
Modified: by Greg Browne
1.1 - Quicksort added - sized down to 300 files for memory saving
Clean up booboos. (4/12/87)
1.2 - EDIT is EXECUTED only, not RUN now & SHOW also - prevents DOS
from trying to get too many things going at once since when
RUN is EXEC'ed, it tries the next one immediately.
Put quotes around filename to allow for multiple word names
1.3 - Minor clean up (4/15/87)
1.4 - Added EXEC f-R & EXEC R-f - removed UnARC (redundant)
Also cleaned up minor message display. (4/18/87)
1.5 - Added WB Startup thanks to Richie Bielack's example (4/20/87)
HAPPY EASTER!
Compiled on TDI's Modula-2 Compiler version 2.20a
If you modify this program and change version numbers,
remember to change the string literal for the window title
which is located in MAIN control area at end of program.
You may modify and/or use this program, but please give credit
where it is due (not only to me, but all the others I drew from)
*)
(* M2: normal library modules *)
FROM SYSTEM IMPORT ADR, NULL,TSIZE,ADDRESS;
FROM Intuition IMPORT IDCMPFlagSet,GadgetPtr,IDCMPFlags;
FROM Ports IMPORT WaitPort;
FROM Memory IMPORT AllocMem,FreeMem,MemReqSet,MemPublic,
MemClear;
FROM DOSLibrary IMPORT DOSBase;
FROM Libraries IMPORT CloseLibrary;
FROM DOSFiles IMPORT Lock,Unlock,AccessRead,FileLock,CurrentDir,
IoErr,InfoData,Info,CreateDir,DeleteFile,
Close,Open,ModeNewFile,FileHandle;
FROM Strings IMPORT Concat,Length,Assign,Insert;
(* Richie Bielack's WorkBench startup module *)
FROM WBStart IMPORT GetWBStartUpMsg,ReturnWBStartUpMsg;
(* My Du Specific library modules *)
FROM DuWindow IMPORT GadgetNames,DuWindowPtr,IOString,DuGads,
CloseDuWindow,OpenDuWindow,SlidePot;
FROM DuDir IMPORT DirEntries,DirTable,ReadDirectory,QSort,
DisplayFiles,NewDir,ClearTable;
FROM DuMisc IMPORT CharPtr,MyMsg,MyClass,MyGadPtr,GadGot,
MyX,MyY,Gp,CheckMessages,DoFileLook,
ReplaceRSDM,StringIt,DuExec,OutHandle,
AskForConfirm,DuMoveFile,DuFileTwiddle;
(* Variables not needed in other modules *)
VAR
Curfirst : CARDINAL; (* current first on screen *)
Curdir, (* current dir name *)
Reqdir : ARRAY [0..90] OF CHAR; (* requested dir name *)
Entrydirlock, (* For later *)
Lastdirlock, (* Temporary may use later *)
Curdirlock, (* Current directory lock *)
Reqdirlock : FileLock; (* Requested dir lock *)
GpCp : CharPtr; (* General purpose pointer *)
wbmsg : ADDRESS; (* WB message if any *)
inf : POINTER TO InfoData; (* for getting INFO *)
(* =================================================================*)
(* Little cleanup routine to make sure some junk isn't displayed *)
PROCEDURE RemoveZaps;
VAR i,j:CARDINAL;
BEGIN
j := 0;
FOR i := 1 TO DirEntries DO
IF (DirTable[i]^.FileName[0] = 177C) THEN INC(j) END;
END;
IF j > 0 THEN QSort; DEC(DirEntries,j) END;
END RemoveZaps;
(* All the 'ok' and ABORT messages call here to keep a million OK
and Operation ABORTED constants from being put into the program
*)
PROCEDURE SayOK;
BEGIN
ReplaceRSDM(msg,"OK");
END SayOK;
PROCEDURE SayAbort;
BEGIN
ReplaceRSDM(msg,"Operation INTERRUPTED");
END SayAbort;
PROCEDURE EndIt(er:LONGINT);
BEGIN
IF er = 0 THEN SayOK
ELSIF er = -1 THEN ReplaceRSDM(msg,"Improper Dest string")
ELSIF er = -2 THEN SayAbort
ELSE DisplayError("Couldn't finish",er);
END;
END EndIt;
PROCEDURE GetReqDir():BOOLEAN;
(* Get directory in Reqdir - or say couldn't by return of FALSE *)
BEGIN
Reqdirlock := Lock(Reqdir,AccessRead);
IF (Reqdirlock = 0) THEN RETURN FALSE END;
IF NOT ReadDirectory(Reqdirlock) THEN
Unlock(Reqdirlock);
RETURN FALSE
ELSE
IF DirEntries > 1 THEN QSort END;
NewDir;
Lastdirlock := CurrentDir(Reqdirlock);
IF Lastdirlock <> 0 THEN Unlock(Lastdirlock) END;
Curdirlock := Reqdirlock;
Assign(Curdir,Reqdir);
Curfirst := 1;
RETURN TRUE
END;
END GetReqDir;
PROCEDURE RedisplayFiles(force:BOOLEAN);
(* If force=TRUE then will be redisplayed anyhow, otherwise only if
more than a screenfull exist
*)
VAR Vpot : CARDINAL;temp:LONGCARD;
BEGIN
IF (DirEntries > 15) OR (force) THEN
Vpot := SlidePot();
temp := LONGCARD(DirEntries - 15);
temp := temp * LONGCARD(Vpot);
Curfirst := CARDINAL(temp DIV 0FFFFH)+1;
IF Vpot = 0FFFFH THEN Curfirst := 999 END;
IF Curfirst > DirEntries - 14 THEN Curfirst := DirEntries - 14 END;
IF Curfirst < 1 THEN Curfirst := 1 END;
DisplayFiles(Curfirst);
END;
END RedisplayFiles;
PROCEDURE GetDev;
(* Get the device hit *)
VAR i:CARDINAL;
BEGIN
GpCp :=CharPtr(DuGads[GadGot].GadgetText^.IText);
i := 0;
DEC(GpCp);
REPEAT
INC(GpCp);
Reqdir[i] := GpCp^;
INC(i);
UNTIL (GpCp^ = 0C);
IF GetReqDir() THEN ReplaceRSDM(source,Reqdir) END;
END GetDev;
PROCEDURE GetSource;
VAR i : CARDINAL;
(* Get the IOString[source] directory if possible
Has several bailout alternatives
*)
BEGIN
i := 0;
WHILE (IOString[source][i] > 40C) AND (i < 90) DO
Reqdir[i] := IOString[source][i];
INC(i);
END;
Reqdir[i] := 0C;
IF (Reqdir[0] = 0C) THEN Assign(Reqdir,":") END;
(* If can't get then switch back to currently selected directory *)
IF NOT GetReqDir() THEN
DisplayError("Couldn't get requested directory",IoErr());
Assign(Reqdir,Curdir);
IF NOT GetReqDir() THEN
DisplayError("Couldn't switch back - going to ram:",IoErr());
GadGot := ram;
GetDev;
END;
ReplaceRSDM(source,Curdir);
END;
SayOK;
END GetSource;
PROCEDURE GetParent;
(* Go to parent or root depending on the gadget hit and in GadGot *)
VAR i, l:CARDINAL; Stop:BOOLEAN;
BEGIN
Assign(Reqdir,IOString[source]);
l := Length(Reqdir);
Stop := FALSE;
REPEAT
DEC(l);
IF (Reqdir[l] = "/") AND (GadGot = parent) THEN
Reqdir[l] := 0C; Stop := TRUE;
ELSIF (Reqdir[l] = ":") THEN
Reqdir[l+1] := 0C; Stop := TRUE;
END;
UNTIL (l=0) OR (Stop);
IF (Reqdir[0] = 0C) THEN Assign(Reqdir,":") END;
ReplaceRSDM(source,Reqdir);
GetSource;
END GetParent;
PROCEDURE SwapStrings(g:GadgetNames);
(* does the shuffling and reselects directory if necessary *)
BEGIN
IF g = rtod THEN ReplaceRSDM(dest, IOString[run] )
ELSIF g = rtos THEN ReplaceRSDM(source,IOString[run] )
ELSIF g = stod THEN ReplaceRSDM(dest, IOString[source])
ELSIF g = stor THEN ReplaceRSDM(run, IOString[source])
ELSIF g = dtor THEN ReplaceRSDM(run, IOString[dest] )
ELSIF g = dtos THEN ReplaceRSDM(source,IOString[dest] )
ELSIF g = swapsd THEN
Assign(Gp,IOString[source]);
ReplaceRSDM(source,IOString[dest]);
ReplaceRSDM(dest,Gp);
ELSIF g = swaprd THEN
Assign(Gp,IOString[run]);
ReplaceRSDM(run,IOString[dest]);
ReplaceRSDM(dest,Gp);
ELSE Assign(Gp,IOString[source]); (* swaprs *)
ReplaceRSDM(source,IOString[run]);
ReplaceRSDM(run,Gp);
END;
CASE g OF
rtos,
dtos,
swaprs,
swapsd : GetSource; |
ELSE
END;
END SwapStrings;
PROCEDURE SelectDir(n:CARDINAL);
(* Select a directory and possibly enter it *)
VAR i,j:CARDINAL;
BEGIN
FOR i := 1 TO DirEntries DO
WITH DirTable[i]^ DO
IF IsDir THEN
IF i=n THEN
IsSelected := NOT IsSelected;
ELSE
IsSelected := FALSE
END;
END;
END;
END;
RedisplayFiles(TRUE);
IF (DirTable[n]^.IsSelected) THEN
ReplaceRSDM(msg,"Click it again to ENTER the directory");
REPEAT (* *) UNTIL CheckMessages();
j := CARDINAL((MyY - 24) DIV 8) + Curfirst;
IF (GadGot = filewindow) AND (j = n) THEN
SayOK;
Assign(Gp,IOString[source]);
IF Gp[Length(Gp)-1] <> ":" THEN
Concat(Gp,"/",Gp);
END;
Concat(Gp,DirTable[n]^.FileName,Gp);
ReplaceRSDM(source,Gp);
GetSource;
ELSE
SayAbort
END;
END;
RedisplayFiles(TRUE);
END SelectDir;
PROCEDURE SelectFile;
(* find, and toggle selection, of a file - branches to SelectDir if
the hit is over a directory name
*)
VAR pos : CARDINAL;
BEGIN
pos := CARDINAL((MyY - 24) DIV 8) + Curfirst;
IF pos <= DirEntries THEN
WITH DirTable[pos]^ DO
IF IsDir THEN
SelectDir(pos)
ELSE
IsSelected := NOT IsSelected;
DisplayFiles(Curfirst);
END
END;
END;
SayOK;
END SelectFile;
PROCEDURE DisplayError(VAR a:ARRAY OF CHAR; de:LONGINT);
(* display error message with DOS error code *)
VAR v:ARRAY[0..33] OF CHAR; dx:LONGCARD;
BEGIN
Assign(Gp,a);
IF de > 0 THEN
dx := LONGCARD(de);
Concat(Gp," - DOS error ",Gp);
IF StringIt(dx,v) THEN END;
Concat(Gp,v,Gp);
END;
ReplaceRSDM(msg,Gp);
END DisplayError;
PROCEDURE SelectAll(v:BOOLEAN);
(* Mass select of all non-directory filenames in the current list
if v is FALSE it is a mass clear instead
*)
VAR i:CARDINAL;
BEGIN
FOR i := 1 TO DirEntries DO
IF DirTable[i]^.IsDir = FALSE THEN DirTable[i]^.IsSelected := v END;
END;
DisplayFiles(Curfirst);
SayOK;
END SelectAll;
PROCEDURE AlreadyGotDest():BOOLEAN;
(* Check to see if the destination path or file exists already
to prevent rename or makedir of duplicate
*)
VAR l:FileLock;
BEGIN
l := Lock(IOString[dest],AccessRead);
IF l <> 0 THEN
Unlock(l);
DisplayError("File or directory exists",IoErr());
RETURN TRUE;
END;
RETURN FALSE;
END AlreadyGotDest;
PROCEDURE DoRename;
(* Rename a file [first one found selected] to the dest gadget name
This routine prevents renaming for CASE changes
i.e. DOIT.ARC to DoIt.arc - sorry, DOS doesn't care, I do.
*)
VAR i,n:CARDINAL;er:LONGINT;l :FileLock;
BEGIN
n := 0;i := 0;
WHILE (n = 0) AND (i < DirEntries) DO
INC(i);
IF DirTable[i]^.IsSelected THEN n := i END;
END;
IF (n > 0) AND (NOT AlreadyGotDest()) THEN
er := DuMoveFile(DirTable[i]^.FileName,IOString[dest]);
IF er = 0 THEN
GetSource;
SayOK;
ELSE
Insert(" to ",Gp,0);
Insert(DirTable[i]^.FileName,Gp,0);
Insert("Couldn't rename ",Gp,0);
DisplayError(Gp,er);
END;
ELSIF (IOString[dest][0] < 41C) THEN
EndIt(LONGINT(-2))
END;
END DoRename;
PROCEDURE DeleteDirectory;
(* Delete a directory if not in use or filled
proposed option is delete even if filled - sort of a mass directory
kill
*)
VAR i,n:CARDINAL;er:LONGINT;l :FileLock;
BEGIN
n := 0;i := 0;
WHILE (n = 0) AND (i < DirEntries) DO
INC(i);
IF (DirTable[i]^.IsSelected) AND (DirTable[i]^.IsDir) THEN n := i END;
END;
IF (n > 0) THEN
IF DeleteFile(DirTable[n]^.FileName) THEN
GetSource;
SayOK;
ELSE
er := IoErr();
Assign(Gp,DirTable[i]^.FileName);
IF (er = 216) THEN
Concat(Gp," not empty",Gp)
ELSE
Insert("Couldn't delete ",Gp,0)
END;
DisplayError(Gp,er);
END;
END;
END DeleteDirectory;
PROCEDURE MakeNewDir;
(* Make new directory if proposed name [dest] not already there
or if [dest] is not null. If no full path is given, it will
make the directory relative to the [source] gadget
*)
VAR l:FileLock;
BEGIN
IF IOString[dest][0] < 41C THEN
EndIt(LONGINT(-1))
ELSIF (NOT AlreadyGotDest()) THEN
l := CreateDir(IOString[dest]);
IF (l = 0) THEN
DisplayError("Couldn't create directory",IoErr());
ELSE
Unlock(l);
SayOK;
GetSource;
END;
END;
END MakeNewDir;
PROCEDURE FillInfo(l:FileLock;VAR s,n:ARRAY OF CHAR);
VAR by:LONGCARD;
BEGIN
IF (l <> 0) THEN
IF Info(l,inf^) THEN
WITH inf^ DO
IF StringIt((idNumBlocks-idNumBlocksUsed)*idBytesPerBlock,n) THEN END;
Insert(s,n,0);
Concat(n," bytes free ",n);
END;
END;
END;
END FillInfo;
PROCEDURE GiveInfo;
(* Gives info on both source and dest - want to add volume name
print as well later.
*)
BEGIN
Gp := "";
Reqdir := "";
inf := AllocMem(TSIZE(InfoData),MemReqSet{MemPublic,MemClear});
IF (inf # NULL) THEN
FillInfo(Curdirlock,"Source: ",Gp);
Reqdirlock := Lock(IOString[dest],AccessRead);
FillInfo(Reqdirlock,"Dest: ",Reqdir);
IF Reqdirlock <> 0 THEN Unlock(Reqdirlock) END;
FreeMem(inf,TSIZE(InfoData));
Concat(Gp,Reqdir,Gp);
ReplaceRSDM(msg,Gp);
ELSE
DisplayError("Couldn't get info block",IoErr());
END;
END GiveInfo;
PROCEDURE WhatBytes;
(* Show total bytes and files for selected filenames
*)
VAR i,j:CARDINAL;b,f:LONGCARD; v:ARRAY[0..33] OF CHAR;
BEGIN
f := 0;b := 0;
FOR i := 1 TO DirEntries DO
WITH DirTable[i]^ DO
IF (IsDir = FALSE) AND (IsSelected) THEN
INC(f);
b := b + LONGCARD(DirTable[i]^.FileSize) + 512
END;
END;
END;
IF StringIt(b,v) THEN END;
Assign(Gp,v);
Concat(Gp," bytes (incl. FileInfoBlocks) in ",Gp);
IF StringIt(f,v) THEN END;
Concat(Gp,v,Gp);
Concat(Gp," files.",Gp);
ReplaceRSDM(msg,Gp);
END WhatBytes;
PROCEDURE DoCopy(wcopy,wdel:BOOLEAN);
(* direction handler and exit handler for the Twiddle procedure
handles COPY, COPYDEL, ZAPFILE, and MOVE
*)
VAR er:LONGINT;
BEGIN
er := DuFileTwiddle(wcopy,wdel);
RemoveZaps;
RedisplayFiles(TRUE);
EndIt(er);
END DoCopy;
PROCEDURE DoDestruct(g:GadgetNames);
(* Handler for all the destructive stuff
COPYDEL, ZAPFILE, and DELDIR all go through here to confirm
*)
BEGIN
AskForConfirm;
REPEAT (* waiting patiently *) UNTIL CheckMessages();
IF (GadGot <> g) THEN
SayAbort;
ELSE
IF g = copydel THEN DoCopy(TRUE,TRUE)
ELSIF g = deldir THEN DeleteDirectory
ELSIF g = zapfile THEN DoCopy(FALSE,TRUE)
END;
END;
END DoDestruct;
(* all GadgetUp messages received in the main routine (LOOP) are sent
here for processing - further branches handle the various work
*)
PROCEDURE ProcessGadgets(gptr:GadgetPtr):BOOLEAN;
BEGIN
(* First check for device gadgets since in the GadgetNames, up to vd0
all are 'get-device' commands *)
IF GadGot <= vd0 THEN
GetDev;
RETURN TRUE; (* no need to waste time looking at other list *)
END;
(* next multiple gadgets using same branch routine
followed by gadgets with separate routines *)
CASE GadGot OF
deldir,
copydel,
zapfile : DoDestruct(GadGot); |
dtor,
dtos,
rtod,
rtos,
stor,
stod,
swaprd,
swaprs,
swapsd : SwapStrings(GadGot); |
arc,
edit,
execfr,
execrf,
runfr,
runrf,
show : EndIt(DuExec());GetSource; |
type,
htype,
print,
hprint : IF DoFileLook() THEN END;
RedisplayFiles(TRUE); |
run,
dest : RETURN TRUE; | (* simply ignore changes *)
move : DoCopy(FALSE,FALSE); |
makedir : MakeNewDir; |
filewindow : SelectFile; |
rename : DoRename; |
source : GetSource; |
copy : DoCopy(TRUE,FALSE); |
info : GiveInfo; |
parent,
root : GetParent; |
slider : RedisplayFiles(FALSE); |
select : SelectAll(TRUE); |
clear : SelectAll(FALSE); |
bytes : WhatBytes; |
ELSE
ReplaceRSDM(msg,"Sorry, maybe next revision!");
END;
RETURN TRUE;
END ProcessGadgets;
(* ---------------------------*)
(* This is the main operating routine. A double loop is used, although
a single WaitPort loop would have worked. Since I wanted a separate
CheckMessages routine which may have NULL results, I did it this
way. Why not?
*)
PROCEDURE GetNextMessage;
BEGIN
(* Outer loop forces wait for message from intuition *)
LOOP
MyMsg := WaitPort(DuWindowPtr^.UserPort);
(* Inner loop gets messages and processes them until NULL message *)
LOOP
IF NOT CheckMessages() THEN EXIT END;
IF MyClass = IDCMPFlagSet{CloseWindowFlag} THEN
RETURN (**** ONLY EXIT so Get out of here ****)
ELSIF (MyClass = IDCMPFlagSet{GadgetUp}) AND ProcessGadgets(MyGadPtr) THEN
ELSIF (MyClass = IDCMPFlagSet{ResfreshWindow}) THEN
RedisplayFiles(TRUE) (* Rest of screen is self-refreshing *)
END
END (* Inner LOOP *)
END; (* Outer LOOP *)
END GetNextMessage;
(********)
(* MAIN *)
(********)
BEGIN
wbmsg := GetWBStartUpMsg();
(* If running from WB then an output window *)
IF wbmsg <> NULL THEN
OutHandle := Open("RAW:0/150/640/49/DuOutputWindow",ModeNewFile)
ELSE
OutHandle := FileHandle(0)
END;
(* Try to open the window - run if successful [log to ram first] *)
(* The literal below is the window title bar display *)
IF OpenDuWindow("DirUtil v1.5 [TDI Modula-2] - by Greg Browne") THEN
GadGot := ram;
GetDev;
GetNextMessage
END;
(* GO HERE ON FAILURE OR FINISH (CloseWindowFlag) *)
(* First free the memory used by the DirTable *)
ClearTable;
(* Close window, graphics library and intuition library if open *)
CloseDuWindow;
(* Unlock the directory lock you're holding (if any) *)
(* Remember to close DOS library too if open *)
IF Curdirlock <> 0 THEN Unlock(Curdirlock) END;
IF DOSBase <> 0 THEN CloseLibrary(DOSBase) END;
IF OutHandle <> 0 THEN Close(OutHandle) END;
ReturnWBStartUpMsg;
END DuM2.